perm filename EVAL2.LSP[W78,JMC] blob
sn#339346 filedate 1978-03-09 generic text, type T, neo UTF8
(DEFUN FFEVAL (E A)
(COND ((ATOM E)
(COND ((OR (EQ E NIL) (EQ E T)) E)
(T (CDR (FFASSOC E A)))))
((ATOM (CAR E))
(COND ((EQ (CAR E) 'QUOTE) (CADR E))
((EQ (CAR E) 'CAR)
(CAR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CDR)
(CDR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CADR)
(CADR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CADDR)
(CADDR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CAAR)
(CAAR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CADAR)
(CADAR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CADDAR)
(CADDAR (FFEVAL (CADR E) A)))
((EQ (CAR E) 'ATOM)
(ATOM (FFEVAL (CADR E) A)))
((EQ (CAR E) 'CONS)
(CONS (FFEVAL (CADR E) A) (FFEVAL (CADDR E) A)))
((EQ (CAR E) 'EQ)
(EQ (FFEVAL (CADR E) A) (FFEVAL (CADDR E) A)))
((EQ (CAR E) 'COND) (FFEVCOND (CDR E) A))
(T (FFEVAL (CONS (CDR (FFASSOC (CAR E) A))
(CDR E))
A))))
((EQ (CAAR E) 'LAMBDA)
(FFEVAL (CADDAR E)
(APPEND (PAIRUP (CADAR E) (FFEVLIS (CDR E) A))
A)))
((EQ (CAAR E) 'LABEL)
(FFEVAL (CONS (CADDAR E) (CDR E))
(CONS (CONS (CADAR E) (CAR E)) A)))))
(DEFUN FFEVLIS (U A)
(COND ((NULL U) NIL)
(T (CONS (FFEVAL (CAR U) A) (FFEVLIS (CDR U) A)))))
(DEFUN FFEVCOND (U A)
(COND ((FFEVAL (CAAR U) A) (FFEVAL (CADAR U) A))
(T (FFEVCOND (CDR U) A))))
(DEFUN FFASSOC (E A)
(COND ((NULL A) NIL)
((EQ E (CAAR A)) (CAR A))
(T (FFASSOC E (CDR A)))))
(DEFUN PAIRUP (U V)
(COND ((NULL U) NIL)
(T (CONS (CONS (CAR U) (CAR V))
(PAIRUP (CDR U) (CDR V))))))